home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / gsubr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-15  |  6.4 KB  |  208 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include "_scm.h"
  45.  
  46.  
  47. /*
  48.  * gsubr.c
  49.  * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
  50.  * and rest arguments.
  51.  */
  52.  
  53. #include "gsubr.h"
  54.  
  55. #define GSUBR_TEST 1
  56.  
  57. #define GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
  58. #define GSUBR_REQ(x) ((int)(x)&0xf)
  59. #define GSUBR_OPT(x) (((int)(x)&0xf0)>>4)
  60. #define GSUBR_REST(x) ((int)(x)>>8)
  61.  
  62. #define GSUBR_MAX 10
  63. #define GSUBR_TYPE(cclo) (VELTS(cclo)[1])
  64. #define GSUBR_PROC(cclo) (VELTS(cclo)[2])
  65.  
  66. static SCM f_gsubr_apply;
  67. #ifdef __STDC__
  68. SCM
  69. scm_make_gsubr(char *name, int req, int opt, int rst, SCM (*fcn)())
  70. #else
  71. SCM
  72. scm_make_gsubr(name, req, opt, rst, fcn)
  73.      char *name;
  74.      int req;
  75.      int opt;
  76.      int rst;
  77.      SCM (*fcn)();
  78. #endif
  79. {
  80.   switch GSUBR_MAKTYPE(req, opt, rst) {
  81.   case GSUBR_MAKTYPE(0, 0, 0): return scm_make_subr(name, tc7_subr_0, fcn);
  82.   case GSUBR_MAKTYPE(1, 0, 0): return scm_make_subr(name, tc7_subr_1, fcn);
  83.   case GSUBR_MAKTYPE(0, 1, 0): return scm_make_subr(name, tc7_subr_1o, fcn);
  84.   case GSUBR_MAKTYPE(1, 1, 0): return scm_make_subr(name, tc7_subr_2o, fcn);
  85.   case GSUBR_MAKTYPE(2, 0, 0): return scm_make_subr(name, tc7_subr_2, fcn);
  86.   case GSUBR_MAKTYPE(3, 0, 0): return scm_make_subr(name, tc7_subr_3, fcn);
  87.   case GSUBR_MAKTYPE(0, 0, 1): return scm_make_subr(name, tc7_lsubr, fcn);
  88.   case GSUBR_MAKTYPE(2, 0, 1): return scm_make_subr(name, tc7_lsubr_2, fcn);
  89.   default:
  90.     {
  91.       SCM symcell = scm_sysintern(name, SCM_UNDEFINED);
  92.       SCM z, cclo = scm_makcclo(f_gsubr_apply, 3L);
  93.       long tmp = ((((CELLPTR)(CAR(symcell)))-scm_heap_org)<<8);
  94.       if (GSUBR_MAX < req + opt + rst) {
  95.     fputs("ERROR in scm_make_gsubr: too many args\n", stderr);
  96.     scm_quit(MAKINUM(1L));
  97.       }
  98.       if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-scm_heap_org))
  99.     tmp = 0;
  100.       NEWCELL(z);
  101.       SUBRF(z) = fcn;
  102.       CAR(z) = tmp + tc7_subr_0;
  103.       GSUBR_PROC(cclo) = z;
  104.       GSUBR_TYPE(cclo) = MAKINUM(GSUBR_MAKTYPE(req, opt, rst));
  105.       CDR(symcell) = cclo;
  106.       return cclo;
  107.     }
  108.   }
  109. }
  110.  
  111.  
  112. PROC (s_gsubr_apply, "gsubr-apply", 0, 0, 1, scm_gsubr_apply);
  113. #ifdef __STDC__
  114. SCM
  115. scm_gsubr_apply(SCM args)
  116. #else
  117. SCM
  118. scm_gsubr_apply(args)
  119.      SCM args;
  120. #endif
  121. {
  122.   SCM self = CAR(args);
  123.   SCM (*fcn)() = SUBRF(GSUBR_PROC(self));
  124.   SCM argv, *v;
  125.   int typ = INUM(GSUBR_TYPE(self));
  126.   int i, n = GSUBR_REQ(typ) + GSUBR_OPT(typ) + GSUBR_REST(typ);
  127.   argv = scm_make_vector(MAKINUM(n), SCM_UNDEFINED);
  128.   v = VELTS(argv);
  129.   args = CDR(args);
  130.   for (i = 0; i < GSUBR_REQ(typ); i++) {
  131. #ifndef RECKLESS
  132.     if (IMP(args))
  133.       scm_wta(SCM_UNDEFINED, (char *)WNA, CHARS(SNAME(GSUBR_PROC(self))));
  134. #endif
  135.     v[i] = CAR(args);
  136.     args = CDR(args);
  137.   }
  138.   for (; i < GSUBR_REQ(typ) + GSUBR_OPT(typ); i++) {
  139.     if (NIMP(args)) {
  140.       v[i] = CAR(args);
  141.       args = CDR(args);
  142.     }
  143.     else
  144.       v[i] = SCM_UNDEFINED;
  145.   }
  146.   if (GSUBR_REST(typ))
  147.     v[i] = args;
  148.   switch (n) {
  149.   default: scm_wta(self, "internal programming error", s_gsubr_apply);
  150.   case 2: return (*fcn)(v[0], v[1]);
  151.   case 3: return (*fcn)(v[0], v[1], v[2]);
  152.   case 4: return (*fcn)(v[0], v[1], v[2], v[3]);
  153.   case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]);
  154.   case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]);
  155.   case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]);
  156.   case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]);
  157.   case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]);
  158.   case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]);
  159.   }
  160. }
  161.  
  162.  
  163. #ifdef GSUBR_TEST
  164. /* A silly example, taking 2 required args, 1 optional, and
  165.    a scm_list of rest args 
  166.    */
  167. SCM
  168. gsubr_21l(req1, req2, opt, rst)
  169.      SCM req1, req2, opt, rst;
  170. {
  171.   scm_puts("gsubr-2-1-l:\n req1: ", cur_outp);
  172.   scm_display(req1, cur_outp);
  173.   scm_puts("\n req2: ", cur_outp);
  174.   scm_display(req2, cur_outp);
  175.   scm_puts("\n opt: ", cur_outp);
  176.   scm_display(opt, cur_outp);
  177.   scm_puts("\n rest: ", cur_outp);
  178.   scm_display(rst, cur_outp);
  179.   scm_newline(cur_outp);
  180.   return UNSPECIFIED;
  181. }
  182. #endif
  183.  
  184. extern char scm_s_lvector_set[];
  185. extern SCM scm_lvector_set();
  186. extern SCM scm_f_lvector_set;
  187. extern char scm_s_throw[];
  188. extern SCM scm_throw();
  189. extern char scm_s_throw_or_retry[];
  190. extern SCM scm_throw_or_retry();
  191. extern SCM scm_utime();
  192. extern char scm_s_utime[];
  193. extern SCM *scm_f_utime;
  194.  
  195. #ifdef __STDC__
  196. void
  197. scm_init_gsubr(void)
  198. #else
  199. void
  200. scm_init_gsubr()
  201. #endif
  202. {
  203.   f_gsubr_apply = scm_make_subr(s_gsubr_apply, tc7_lsubr, scm_gsubr_apply);
  204. #ifdef GSUBR_TEST
  205.   scm_make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
  206. #endif
  207. }
  208.